home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / backq.c < prev    next >
C/C++ Source or Header  |  1987-06-04  |  6KB  |  383 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. #include "include.h"
  8.  
  9. #define    attach(x)    (vs_head = make_cons(x, vs_head))
  10. #define    make_list    (vs_push(Cnil), stack_cons(), stack_cons())
  11.  
  12.  
  13. #define    QUOTE    1
  14. #define    EVAL    2
  15. #define    LIST    3
  16. #define    LISTA    4
  17. #define    APPEND    5
  18. #define    NCONC    6
  19.  
  20. object siScomma;
  21. object siScomma_at;
  22. object siScomma_dot;
  23.  
  24. object Slist;
  25. object SlistA;
  26. object Sappend;
  27. object Snconc;
  28.  
  29. object Sapply;
  30. object Svector;
  31.  
  32. kwote_cdr()
  33. {
  34.     object x;
  35.  
  36.     x = vs_head;
  37.     if (type_of(x) == t_symbol) {
  38.         if ((enum stype)x->s.s_stype == stp_constant &&
  39.             x->s.s_dbind == x)
  40.             return;
  41.         goto KWOTE;
  42.     } else if (type_of(x) == t_cons || type_of(x) == t_vector)
  43.         goto KWOTE;
  44.     return;
  45.  
  46. KWOTE:
  47.     vs_head = make_cons(vs_head, Cnil);
  48.     vs_head = make_cons(Squote, vs_head);
  49. }
  50.  
  51. kwote_car()
  52. {
  53.     object x;
  54.  
  55.     x = vs_top[-2];
  56.     if (type_of(x) == t_symbol) {
  57.         if ((enum stype)x->s.s_stype == stp_constant &&
  58.             x->s.s_dbind == x)
  59.             return;
  60.         goto KWOTE;
  61.     } else if (type_of(x) == t_cons || type_of(x) == t_vector)
  62.         goto KWOTE;
  63.     return;
  64.  
  65. KWOTE:
  66.     vs_top[-2] = make_cons(vs_top[-2], Cnil);
  67.     vs_top[-2] = make_cons(Squote, vs_top[-2]);
  68. }
  69.  
  70. /*
  71.     Backq_cdr(x) pushes a form on vs and returns one of
  72.  
  73.         QUOTE        the form should be quoted
  74.         EVAL        the form should be evaluated
  75.         LIST        the form should be applied to LIST
  76.         LISTA        the form should be applied to LIST*
  77.         APPEND        the form should be applied to APPEND
  78.         NCONC        the form should be applied to NCONC
  79. */
  80. int
  81. backq_cdr(x)
  82. object x;
  83. {
  84.     int a, d;
  85.  
  86.     cs_check(x);
  87.  
  88.     if (type_of(x) != t_cons) {
  89.         vs_push(x);
  90.         return(QUOTE);
  91.     }
  92.     if (x->c.c_car == siScomma) {
  93.         vs_push(x->c.c_cdr);
  94.         return(EVAL);
  95.     }
  96.     if (x->c.c_car == siScomma_at || x->c.c_car == siScomma_dot)
  97.         FEerror(",@ or ,. has appeared in an illegal position.", 0);
  98.     a = backq_car(x->c.c_car);
  99.     d = backq_cdr(x->c.c_cdr);
  100.     if (d == QUOTE)
  101.         switch (a) {
  102.         case QUOTE:
  103.             vs_pop;
  104.             vs_head = x;
  105.             return(QUOTE);
  106.  
  107.         case EVAL:
  108.             if (vs_head == Cnil) {
  109.                 stack_cons();
  110.                 return(LIST);
  111.             }
  112.             if (type_of(vs_head) == t_cons &&
  113.                 vs_head->c.c_cdr == Cnil) {
  114.                 vs_head = vs_head->c.c_car;
  115.                 kwote_cdr();
  116.                 make_list;
  117.                 return(LIST);
  118.             }
  119.             kwote_cdr();
  120.             make_list;
  121.             return(LISTA);
  122.  
  123.         case APPEND:
  124.             if (vs_head == Cnil) {
  125.                 vs_pop;
  126.                 return(EVAL);
  127.             }
  128.             kwote_cdr();
  129.             make_list;
  130.             return(APPEND);
  131.  
  132.         case NCONC:
  133.             if (vs_head == Cnil) {
  134.                 vs_pop;
  135.                 return(EVAL);
  136.             }
  137.             kwote_cdr();
  138.             make_list;
  139.             return(NCONC);
  140.  
  141.         default:
  142.             error("backquote botch");
  143.         }
  144.     if (d == EVAL)
  145.         switch (a) {
  146.         case QUOTE:
  147.             kwote_car();
  148.             make_list;
  149.             return(LISTA);
  150.  
  151.         case EVAL:
  152.             make_list;
  153.             return(LISTA);
  154.  
  155.         case APPEND:
  156.             make_list;
  157.             return(APPEND);
  158.  
  159.         case NCONC:
  160.             make_list;
  161.             return(NCONC);
  162.  
  163.         default:
  164.             error("backquote botch");
  165.         }
  166.     if (a == d) {
  167.         stack_cons();
  168.         return(d);
  169.     }
  170.     switch (d) {
  171.     case LIST:
  172.         if (a == QUOTE) {
  173.             kwote_car();
  174.             stack_cons();
  175.             return(d);
  176.         }
  177.         if (a == EVAL) {
  178.             stack_cons();
  179.             return(d);
  180.         }
  181.         attach(Slist);
  182.         break;
  183.  
  184.     case LISTA:
  185.         if (a == QUOTE) {
  186.             kwote_car();
  187.             stack_cons();
  188.             return(d);
  189.         }
  190.         if (a == EVAL) {
  191.             stack_cons();
  192.             return(d);
  193.         }
  194.         attach(SlistA);
  195.         break;
  196.  
  197.     case APPEND:
  198.         attach(Sappend);
  199.         break;
  200.  
  201.     case NCONC:
  202.         attach(Snconc);
  203.         break;
  204.  
  205.     default:
  206.         error("backquote botch");
  207.     }
  208.     switch (a) {
  209.     case QUOTE:
  210.         kwote_car();
  211.         make_list;
  212.         return(LISTA);
  213.  
  214.     case EVAL:
  215.         make_list;
  216.         return(LISTA);
  217.  
  218.     case APPEND:
  219.         make_list;
  220.         return(APPEND);
  221.  
  222.     case NCONC:
  223.         make_list;
  224.         return(NCONC);
  225.  
  226.     default:
  227.         error("backquote botch");
  228.     }
  229. }
  230.  
  231. /*
  232.     Backq_car(x) pushes a form on vs and returns one of
  233.  
  234.         QUOTE        the form should be quoted
  235.         EVAL        the form should be evaluated
  236.         APPEND        the form should be appended
  237.                 into the outer form
  238.         NCONC        the form should be nconc'ed
  239.                 into the outer form
  240. */
  241. int
  242. backq_car(x)
  243. object x;
  244. {
  245.     int d;
  246.  
  247.     cs_check(x);
  248.  
  249.     if (type_of(x) != t_cons) {
  250.         vs_push(x);
  251.         return(QUOTE);
  252.     }
  253.     if (x->c.c_car == siScomma) {
  254.         vs_push(x->c.c_cdr);
  255.         return(EVAL);
  256.     }
  257.     if (x->c.c_car == siScomma_at) {
  258.         vs_push(x->c.c_cdr);
  259.         return(APPEND);
  260.     }
  261.     if (x->c.c_car == siScomma_dot) {
  262.         vs_push(x->c.c_cdr);
  263.         return(NCONC);
  264.     }
  265.     d = backq_cdr(x);
  266.     switch (d) {
  267.     case QUOTE:
  268.         return(QUOTE);
  269.  
  270.     case EVAL:
  271.         return(EVAL);
  272.  
  273.     case LIST:
  274.         attach(Slist);
  275.         break;
  276.  
  277.     case LISTA:
  278.         attach(SlistA);
  279.         break;
  280.  
  281.     case APPEND:
  282.         attach(Sappend);
  283.         break;
  284.  
  285.     case NCONC:
  286.         attach(Snconc);
  287.         break;
  288.  
  289.     default:
  290.         error("backquote botch");
  291.         }
  292.     return(EVAL);
  293. }
  294.  
  295. object
  296. backq(x)
  297. object x;
  298. {
  299.     int a;
  300.  
  301.     a = backq_car(x);
  302.     if (a == APPEND || a == NCONC)
  303.         FEerror(",@ or ,. has appeared in an illegal position.", 0);
  304.     if (a == QUOTE)
  305.         kwote_cdr();
  306.     return(vs_pop);
  307. }
  308.  
  309. Lcomma_reader()
  310. {
  311.     object in, c;
  312.  
  313.     check_arg(2);
  314.     vs_pop;
  315.     in = vs_base[0];
  316.     if (backq_level <= 0)
  317.         FEerror("A comma has appeared out of a backquote.", 0);
  318.     c = peek_char(FALSE, in);
  319.     if (c == code_char('@')) {
  320.         vs_push(siScomma_at);
  321.         read_char(in);
  322.     } else if (c == code_char('.')) {
  323.         vs_push(siScomma_dot);
  324.         read_char(in);
  325.     } else
  326.         vs_push(siScomma);
  327.     --backq_level;
  328.     vs_push(read_object(in));
  329.     backq_level++;
  330.     stack_cons();
  331.     vs_base[0] = vs_base[1];
  332.     vs_pop;
  333. }
  334.  
  335. Lbackquote_reader()
  336. {
  337.     object in;
  338.  
  339.     check_arg(2);
  340.     vs_pop;
  341.     in = vs_base[0];
  342.     backq_level++;
  343.     vs_base[0] = read_object(in);
  344.     --backq_level;
  345.     vs_base[0] = backq(vs_base[0]);
  346. }
  347.  
  348. #define    make_cf(f)    make_cfun((f), Cnil, Cnil, NULL, 0);
  349.  
  350. init_backq()
  351. {
  352.     object r;
  353.  
  354.     siScomma = make_si_ordinary(",");
  355.     enter_mark_origin(&siScomma);
  356.     siScomma_at = make_si_ordinary(",@");
  357.     enter_mark_origin(&siScomma_at);
  358.     siScomma_dot = make_si_ordinary(",.");
  359.     enter_mark_origin(&siScomma_dot);
  360.  
  361.     Slist = make_ordinary("LIST");
  362.     enter_mark_origin(&Slist);
  363.     SlistA = make_ordinary("LIST*");
  364.     enter_mark_origin(&SlistA);
  365.     Sappend = make_ordinary("APPEND");
  366.     enter_mark_origin(&Sappend);
  367.     Snconc = make_ordinary("NCONC");
  368.     enter_mark_origin(&Snconc);
  369.  
  370.     Sapply = make_ordinary("APPLY");
  371.     enter_mark_origin(&Sapply);
  372.     Svector = make_ordinary("VECTOR");
  373.     enter_mark_origin(&Svector);
  374.  
  375.     r = standard_readtable;
  376.     r->rt.rt_self['`'].rte_chattrib = cat_terminating;
  377.     r->rt.rt_self['`'].rte_macro = make_cf(Lbackquote_reader);
  378.     r->rt.rt_self[','].rte_chattrib = cat_terminating;
  379.     r->rt.rt_self[','].rte_macro = make_cf(Lcomma_reader);
  380.  
  381.     backq_level = 0;
  382. }
  383.